;;;;
;;;; DEFAULT - do nothing
;;;; Note that initial values for variable declarations get simplified
;;;; destructively in the simplify methods for lets and definitions.
;;;;

(define-method (simplify (e expression))
  e)

;;;;
;;;; TOP-LEVEL FORMS
;;;;

;(define-method (simplify (d definition))
;  (define v (var d))
;  (set (initial-value v)
;       (simplify (initial-value v)))
;  d)

(define-method (simplify (cd class-definition))
  (new class-definition
       (name cd)
       (parent cd)
       (interfaces cd)
       (initargs cd)
       (map simplify (members cd))
       (attributes cd)))

(define-method (simplify (md member-definition))
  (new member-definition
       (var md)
       (native-name md)
       (keywords md)
       (rtype md)
       (simplify (value md))))

;;;;
;;;; APPLICATIONS
;;;;

(define-method (simplify (e application))
  (hoist-begins (new application
		     (simplify (operator e))
		     (map simplify (arguments e)))
		identity))

;;;;
;;;; SPECIAL FORMS
;;;;

(define-method (simplify (r return))
  (new return (simplify (exp r))))

(define-method (simplify (s set-expression))
  (hoist-begins (simplify (rvalue s))
		(lambda (simplified-rvalue)
		  (new set-expression
		       (lvalue s)
		       simplified-rvalue))))

(define-method (simplify (c cast-expression))
  (hoist-begins (simplify (exp c))
		(lambda (simplified)
		  (new cast-expression
		       (declared-type c)
		       simplified))))

(define-method (simplify (c conditional))
  (new conditional
       (simplify (test c))
       (simplify (consequent c))
       (if (null? (alternative c))
	   '()
	   (simplify (alternative c)))))

(define-method (simplify (e begin-expression))
  (let ((flattened (append-map (lambda (f)
				 (if (eq? (object-class f)
					  begin-expression)
				     (body f)
				     (list f)))
			       (map simplify (body e)))))
    (if (= (length flattened) 1)
	(car flattened)
	(new begin-expression flattened))))

(define-method (simplify (l lambda-expression))
  (new lambda-expression
       (variables l)
       (map simplify (body l))
       (snl l)))

(define-method (simplify (l let-expression))
  (for-each (lambda (var)
	      (set (initial-value var)
		   (simplify (initial-value var))))
	    (variables l))
  (new let-expression
       (variables l)
       (map simplify (body l))
       (snl l)))

(define-method (simplify (l for-expression))
  (for-each (lambda (var)
	      (set (initial-value var)
		   (simplify (initial-value var))))
	    (variables l))
  (new for-expression
       (variables l)
       (simplify (test l))
       (map simplify (iterators l))
       (map simplify (body l))
       (snl l)))

(define-method (simplify (w while-expression))
  (new while-expression
       (simplify (test w))
       (map simplify (body w))))

;;;;
;;;; HOISTING BEGINS
;;;;

(define (identity x) x)

(define-method (hoist-begins (e expression) k)
  (k e))

(define-method (hoist-begins (a application) k)
  (let loop ((args (arguments a))
	     (sanitized-args '())
	     (k k))
    (cond ((null? args)
	   (k (new application
		   (operator a)
		   (reverse sanitized-args))))
	  (else
	   (let ((first (car args))
		 (rest (cdr args)))
	     (hoist-begins first
			   (lambda (sanitized)
			     (loop rest
				   (cons sanitized
					 sanitized-args)
				   k))))))))

(define (hoist-body forms k)
  (append (drop-right forms 1)
	  (list (hoist-begins (last forms)
			      k))))

(define-method (hoist-begins (b begin-expression) k)
  (define new-body
    (hoist-body (body b) k))
  (if (= (length new-body) 1)
      (car new-body)
      (new begin-expression new-body)))

(define-method (hoist-begins (l let-expression) k)
  (new let-expression
       (variables l)
       (hoist-body (body l) k)
       (snl l)))

(define-method (hoist-begins (f for-expression) k)
  (error "Compiler error: trying to hoist a for loop.  This shouldn't happen."
	 (unparse f)))

(define-method (hoist-begins (w while-expression) k)
  (error "Compiler error: trying to hoist a while loop.  This shouldn't happen."
	 (unparse w)))

(comment
(pretty-print
 (unparse
  (hoist-begins (parse '(+ 1
			   (begin 1 2
				  (begin 3 4))))
		identity)))
)